home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Caml Light 0.7 / Caml Light 0.7 source / src / tools / dumpobj.ml < prev    next >
Text File  |  1995-06-01  |  4KB  |  131 lines
  1. (* To show the contents of a .zo file.*)
  2.  
  3. (*
  4. camlc -g -o dumpobj -I ../lib -I ../compiler -I ../linker printexc.zo opcodes.zo dumpobj.ml
  5. *)
  6.  
  7. #open "const";;
  8. #open "reloc";;
  9. #open "emit_phr";;
  10. #open "opcodes";;
  11. #open "opnames";;
  12.  
  13. let input_u16 ic =
  14.   let b1 = input_byte ic in
  15.   let b2 = input_byte ic in
  16.     b1 + lshift_left b2 8
  17. ;;
  18.  
  19. let input_s16 ic =
  20.   let b1 = input_byte ic in
  21.   let b2 = input_byte ic in
  22.   let n = b1 + lshift_left b2 8 in
  23.   if n >= 32768 then n - 65536 else n
  24. ;;
  25.  
  26. let input_s32 ic =
  27.   let b1 = input_byte ic in
  28.   let b2 = input_byte ic in
  29.   let b3 = input_byte ic in
  30.   let b4 = input_byte ic in
  31.     b1 + lshift_left b2 8 + lshift_left b3 16 + lshift_left b4 24
  32. ;;
  33.  
  34. let print_code ic len =
  35.   let start = pos_in ic in
  36.   let print_depl ic =
  37.     let orig = pos_in ic - start in
  38.       print_int (orig + input_s16 ic) in
  39.   let stop = start + len in
  40.     while pos_in ic < stop do
  41.       print_int (pos_in ic - start); print_string "\t";
  42.       let op = input_byte ic in
  43.         if op >= vect_length names_of_instructions then
  44.           print_string "??? "
  45.         else begin
  46.           print_string names_of_instructions.(op); print_string " "
  47.         end;
  48.         if op == ACCESS or op == DUMMY or op == ENDLET
  49.         or op == CONSTBYTE or op == ATOM or op == GETFIELD or op == SETFIELD
  50.         or op == MAKEBLOCK1 or op == MAKEBLOCK2 or op == MAKEBLOCK3
  51.         or op == MAKEBLOCK4 then
  52.           print_int(input_byte ic)
  53.         else if op == GETGLOBAL or op == SETGLOBAL
  54.         or op == PUSH_GETGLOBAL_APPLY or op == PUSH_GETGLOBAL_APPTERM
  55.         or op == C_CALL1 or op == C_CALL2 or op == C_CALL3
  56.         or op == C_CALL4 or op == C_CALL5 then
  57.           print_int(input_u16 ic)
  58.         else if op == CONSTSHORT then
  59.           print_int(input_s16 ic)
  60.         else if op == MAKEBLOCK then
  61.           print_int(input_s32 ic)
  62.         else if op == CUR or op == LETREC1 or op == PUSHTRAP
  63.         or op == BRANCH or op == BRANCHIF or op == BRANCHIFNOT
  64.         or op == POPBRANCHIFNOT or op == BRANCHIFEQ or op == BRANCHIFNEQ
  65.         or op == BRANCHIFLT or op == BRANCHIFGT or op == BRANCHIFLE
  66.         or op == BRANCHIFGE then
  67.           print_depl ic
  68.         else if op == FLOATOP then
  69.           print_string names_of_float_instructions.(input_byte ic)
  70.         else if op == SWITCH then
  71.           (let n = input_byte ic in
  72.            let orig = pos_in ic - start in
  73.              for i = 0 to n-1 do
  74.                print_int (orig + input_s16 ic); print_string ", "
  75.              done)
  76.         else if op == BRANCHINTERVAL then
  77.           (print_depl ic; print_string ", "; print_depl ic)
  78.         else if op == C_CALLN then
  79.           (print_int(input_byte ic);
  80.            print_string ", ";
  81.            print_int(input_u16 ic))
  82.         else
  83.           ();
  84.         print_newline()
  85.     done
  86. ;;
  87.  
  88. let print_global g =
  89.   print_string g.qual; print_string "__"; print_endline g.id
  90. ;;
  91.  
  92. let print_reloc (info, pos) =
  93.   print_string "\t"; print_int pos; print_string "\t";
  94.   match info with
  95.     Reloc_literal _ -> print_endline "const"
  96.   | Reloc_getglobal g -> print_string "require\t"; print_global g
  97.   | Reloc_setglobal g -> print_string "provide\t"; print_global g
  98.   | Reloc_tag(g,s) -> print_string "exc.tag\t"; print_global g
  99.   | Reloc_primitive s -> print_string "prim\t"; print_endline s
  100. ;;
  101.  
  102. let print_entry ic phr =
  103.   print_string "Offset ";
  104.   print_int phr.cph_pos;
  105.   print_string ", length ";
  106.   print_int phr.cph_len;
  107.   if phr.cph_pure then print_endline ", pure" else print_endline ", impure";
  108.   seek_in ic phr.cph_pos;
  109.   print_code ic phr.cph_len;
  110.   do_list print_reloc phr.cph_reloc
  111. ;;
  112.  
  113. let dump filename =
  114.   print_string "File "; print_endline filename;
  115.   let ic = open_in_bin filename in
  116.   let n = input_binary_int ic in
  117.   seek_in ic n;
  118.   let index = (input_value ic : compiled_phrase list) in
  119.   do_list (print_entry ic) (rev index);
  120.   close_in ic
  121. ;;
  122.  
  123. let main() =
  124.   for i = 1 to vect_length sys__command_line - 1 do
  125.     dump sys__command_line.(i)
  126.   done;
  127.   exit 0
  128. ;;
  129.  
  130. printexc__f main ();;
  131.